home *** CD-ROM | disk | FTP | other *** search
/ BMUG Revelations / BMUG Revelations.toast / Programming / Programming Languages / Yerk 3.64 / Module source / docmod (.txt) < prev    next >
Microsoft Windows Help File Content  |  1993-06-18  |  11KB  |  284 lines
  1. :module docmod
  2. // ctl
  3. // ctlwind
  4. // vscroll
  5. // textedit
  6. 0 value eop
  7. : getWidth    option?
  8.     IF -1 -> eop ELSE getvrect: actw drop 15 - 6 / 20 / 20 * 21 - -> eop 2drop THEN ;
  9. : (marks) ( cfa filemk --)
  10.     over @ = IF  >name dup
  11.                   8 .r  3 spaces n>count type out eop >
  12.                   IF cr 0 -> out ELSE 26 out over mod - spaces THEN
  13.              ELSE drop
  14.              THEN ?pause ;
  15. \ same as 'words'..lists all filemarks
  16. \ hold down option key to get single column
  17. : marks  getWidth 0 -> out
  18.     base >r hex
  19.     'c (marks) filemk trav cr
  20.     r> -> base ; 
  21. 0 value mkCfa    \ the file mark cfa
  22. \ define a word to check each cfa in the fmark vocab, and if it is earlier
  23. \  in the dictionary than the cfa of the word we are testing to see which
  24. \  file it is in, then we must have found the mark...set a flag.
  25. : (findMk)    \ ( cfa wordcfa -- )  
  26.            over > IF dup  -> mkCfa @ filemk = -> endTrav? ELSE drop THEN ;
  27. \ find first mark above the wordcfa - returns true if mark found
  28. : findFMark    \ ( wordcfa -- cfa t or f)        - could also be addr
  29.     LoCase
  30.     'c (findMk)  swap trav
  31.     UpCase
  32.     endTrav? IF mkCfa true ELSE false THEN ;
  33. \ get source name from mark
  34. : srcName  ( cfa -- addr len) findFMark not abort" No Mark"
  35.      >name n>count  ;
  36. : (forget) ( pfa --)    dup nfa >line -> dp lfa @ current ! ;
  37. : mforget LoCase [compile] ' (forget) Upcase ;
  38. \ forget to last mark
  39. : FM here findFMark 0= abort" no mark found"
  40.      >body (forget) ;
  41. \ reload last file, forgetting to mark
  42. : RL here srcname fm new: loadfile
  43.     name: topfile interpret: topfile remove: loadfile ;
  44. \ *** reload sources from named mark
  45. string LoadList    \ make the filelist here
  46. string tempStr    \ use in place of parmstr, since parmstr defined in Frontend
  47. \ identify all source names from latest to the entered mark and fill filelist
  48. : (files) ( cfa cfa0 --)
  49.     over <=
  50.     IF dup @ filemk =
  51.         IF " // " put: tempStr >name n>count add: tempStr  13 +: tempStr lock: tempStr
  52.            get: tempStr start: LoadList insert: LoadList unlock: tempStr
  53.         ELSE drop THEN
  54.     ELSE drop true -> endTrav?
  55.     THEN ;
  56. \ find filenames
  57. : files ( -- pfa) new: tempStr
  58.     clear: LoadList 'c (files) locase [compile] ' dup >r upcase 4- latest (trav) r>
  59.     release: tempStr ;
  60. : loadKey
  61.     next: LoadList 0=
  62.     IF rekey 13 THEN ;    \ simulate a terminal cr
  63. \ interpret from the scrap
  64. : Doit size: loadlist 0>
  65.     IF start: loadlist 'c loadKey -> keyVec  THEN sp! mp! quit ;
  66. \ interpret LoadList
  67. : reload loadKey doit ;
  68. \ make file list, forget to the mark, and the reload the list.
  69. \ usage:  /// filename
  70. \ will rebuild from 'filename' to latest
  71. : /// new: LoadList files (forget) reload release: LoadList ;
  72. \ 1.31.92    rfl    modified recalscroll
  73. \ DISABLE MESSAGE SENT AFTER CLOSED!!!
  74. \ class that is only for displaying scrolling, word wrapped text
  75. \  has a vertical scroll bar attached at right, with grow box.
  76. \  scroll region is entire window minus the scroll bar
  77. :CLASS TeScrollRect <super TextEdit
  78.     var        myVScroll        \ scrollbar ptr
  79.     rect    boundsRect        \ turns out is content region 
  80.     int        atLine            \ internal use for keeping text at same line after grow
  81.     var        myWindow        \ used to determine if window is active for scroll bar
  82.   :M putScroll: ( n --) put: myVScroll ;M
  83.   :M lineHeight: ( -- n) m@ >ptr 24 + w@ ;M
  84.   :M nlines: ( -- n) m@ >ptr 94 + w@ ;M
  85.   :M putLine: ( n --) put: atLine ;M
  86. \ returns top line
  87.   :M where: ( -- line#)  getTopY: destrect    \ subtract y0 of original dest rect    
  88.     m@ >ptr getTopY: rect - lineHeight: self / ;M    \ get y0 of internal dest rect
  89. \  :M topChar: m@ >ptr 96 + where: self 2* + w@ ;M
  90. \ get number of whole lines
  91.   :M visibleLines: ( -- n) ptr: self 8+ size: rect swap drop lineheight: self / ;M
  92. \ boundsRect of two textctls can't be too close vertically: > 4 pixels 
  93.   :M putRect: { l t r b  -- } l t r b put: boundsRect
  94.     l 4+ t 2+ r 18 - b 2-  putRect: super m@
  95.     IF get: destRect drop over visibleLines: self lineHeight: self * +
  96.         ptr: self 8+ put: rect
  97.     THEN ;M
  98. \ return max first line
  99.   :M maxRange: ( -- n) nlines: self visibleLines: self -  1+ ;M
  100.   :M new: { myWind -- } myWind put: myWindow
  101.     myWind new: super
  102.     getBotX: boundsRect 15 - getTopY: boundsRect
  103.     size: boundsRect swap drop myWind new: [ obj: myVScroll ]
  104.     disable: [ obj: myVScroll ]
  105.     1 1 putRange: [ obj: myVScroll ] ;M
  106.   :M close: close: [ obj: myVScroll ] close: super  ;M
  107.   :M draw: pushPort set: [ obj: myWindow ] draw: super popPort ;M
  108. \ move text record to line# as first line in rect
  109.   :M moveto: { line# \ y -- } 0
  110.     line#  maxRange: self 1- min 0 max \ negate  \ where we want it to be
  111.     where: self                                \ where are we now?
  112.     - lineHeight: self * negate                \ translate to pixel offset
  113.     m@ >ptr offset: rect line# put: atLine draw: self
  114.     where: self 1+ put: [ obj: myVScroll ] ;M
  115. \ recalibrate scroll bar size, range, and set text
  116.   :M recalScroll: 1 maxRange: self 1 max
  117.     putRange: [ obj: myVScroll ]
  118.     nlines: self visibleLines: self > active: [ obj: myWindow ] and
  119.     IF enable: [ obj: myVScroll ] THEN
  120.      get: atLine maxRange: self 1- min 0 max moveto: self            \ stay at about where we were before grow
  121.       ;M
  122.   :M find: { addr len \ myText offset off1 -- offset line T or F }
  123.         heap> sarray -> myText new: myText 13 putChar: mytext
  124.         getText: super place: myText
  125.         start: myText addr len myText indexof: string
  126.         IF 1- -> offset
  127.              ptr: myText offset + bl parse -> off1 drop
  128.              bl parse offset + off1 + offset swap setSelect: self 2drop
  129.             limit: myText 1
  130.             DO offset i ^elem: myText 0 ^elem: myText - <
  131.                 IF i leave THEN
  132.             LOOP moveto: self recalscroll: self
  133.         THEN release: myText dispose> myText ;M
  134. \ recal really slows things down
  135.   :M addText: ( addr len --) addtext: super recalScroll: self ;M
  136.   :M put: ( addr len --) clear: super addText: self ;M
  137.   :M grow: ( l t r b -- ) where: self put: atLine
  138.      putRect: self
  139.     16 size: boundsRect swap drop 15 - size: [ obj: myVScroll ]
  140.     getBotX: boundsRect 15 - getTopY: boundsRect moveto: [ obj: myVScroll ]
  141.     recal: self
  142.     recalScroll: self ( draw: self)  ;M
  143.   :M activate: activate: super enable: [ obj: myVScroll ] ;M
  144.   :M deactivate: deactivate: super disable: [ obj: myVScroll ] ;M
  145. \  :M exec: activate: self click: super ;M
  146. ;CLASS
  147. \ class to contain the teScrollRect
  148. :CLASS ScrollWind <super ctlWind
  149.     var     myTextPane    \ pointer to teScrollRect
  150.   :M putPane: ( n --) put: myTextPane ;M
  151.   :M close:  close: [ obj: myTextPane ] close: super ;M
  152. \ draw only the grow box, no horizontal scroll lines
  153.   :M clipGrow: { \ b r scratchRgn -- } 
  154.     get: growFlg
  155.     IF 0 call NewRgn -> scratchRgn
  156.         scratchRgn call getClip
  157.         getRect: self 2swap 2drop -> b -> r
  158.         r 15 - 0 r b put: tempRect clip: tempRect
  159.         @xy (abs) call DrawGrowIcon gotoxy
  160.         scratchRgn call setClip scratchRgn call disposeRgn
  161.     THEN ;M
  162. \ same draw as window, except that we clip the grow rect when drawing it.
  163.     :M  DRAW:    get: fPrect
  164.         (abs) call BeginUpdate
  165.         savePort @xy set: self
  166.         clipGrow: self
  167.         exec: draw    gotoxy    \ call user draw routine
  168.         (abs) call EndUpdate 
  169.         put: fPrect 
  170.         draw: [ obj: myTextPane ] restport ;M
  171.     \ ( -- )  response to activate event - want to draw only grow rect
  172.     :M  ENABLE:  
  173.         ^base -> actW                \ commence idle handler
  174.         set: self
  175.         clipGrow: self
  176.         activate: [ obj: myTextPane ]
  177.         exec: Enact ;M
  178.   :M disable: deactivate: [ obj: myTextPane ]
  179.         0 -> actw clipGrow: self exec: deact ;M
  180.   :M (grow): getVrect: self put: temprect -4 0 offset: temprect clear: temprect
  181.         getrect: self 2+ swap 1+ swap put: temprect -1 -1 offset: temprect
  182.         get: temprect grow: [ obj: myTextPane ] ;M
  183.  :M grow: Get: growFlg
  184.         IF     0 (abs) Where: fEvent  abs: growrect
  185.             call GrowWindow -dup
  186.             IF unpack size: self (grow): [ ^base ] setView: self THEN
  187.         THEN  select: self ;M
  188.   :M new: alive: super not
  189.     IF new: super ^base new: [ obj: myTextPane ] 
  190.         setLimits: self \ activate: [ obj: myTextPane ]
  191.         (grow): [ ^base ]
  192.     THEN ( select: self) ;M
  193.   :M addText: ( addr len --) alive: self
  194.     IF pushPort >r set: self addText: [ obj: myTextPane ] r> popPort
  195.     ELSE 2drop
  196.     THEN ;M
  197.   :M print: ( addr len --) alive: self
  198.     IF pushPort >r set: self put: [ obj: myTextPane ] r> popPort
  199.     ELSE 2drop
  200.     THEN ;M
  201.   :M key: { char -- } char $ ff and -> char
  202.         command?
  203.         IF char 
  204.             CASE
  205.                 ascii c  char ascii C = or    OF teCopy:  [ obj: myTextPane ]    ENDOF
  206.                 ascii x  char ascii X = or    OF teCut:   [ obj: myTextPane ] ENDOF
  207.                 ascii v  char ascii V = or    OF tePaste: [ obj: myTextPane ]    ENDOF
  208.             ENDCASE
  209.         ELSE  char key: [ obj: myTextPane ]
  210.         THEN ;M
  211.   :M content:
  212.     pushPort ^base set: grafPort ^base ctlhit? not
  213.     IF select: self click: [ obj: myTextPane ]
  214.     THEN  popPort ;M
  215.   :M idle: ptIn: [ obj: myTextPane ]
  216.         IF ibeamCurs idle: [ obj: myTextPane ] ELSE arrowCurs THEN exec: idle ;M
  217. ;CLASS
  218. \ instantiate objects
  219. ScrollWind dwind
  220. tescrollrect dPane
  221. vscroll dscroll
  222. dscroll putScroll: dPane
  223. dPane putPane: dwind
  224. \ 2  2 270 120 putrect:    dPane
  225. 270 61 640 300 true setgrow: dwind
  226. : buildDWind pushPort alive: dwind not
  227.     IF  2 40 542 200 put: temprect
  228.         temprect 0 0 docwind false true new: dwind
  229.     THEN dup call selectWindow popPort ;
  230. : lndn get: myCtl 1+ dup put: myCtl maxRange: dPane <=
  231.     IF 0 lineHeight: dPane negate scroll: dPane THEN ;
  232. : lnup get: myCtl 1- dup put: myCtl  0>
  233.     IF 0 lineHeight: dPane  scroll: dPane THEN ;
  234. : pgdn get: myCtl visibleLines: dPane 1- + put: myCtl get: myCtl 1- moveto: dPane ;
  235. : pgup get: myCtl visibleLines: dPane 1- - put: myCtl get: myCtl 1- moveto: dPane ;
  236. : doth get: myCtl put: myCtl get: myCtl 1- moveto: dPane ;
  237. 5 'cfas lnup lndn pgup pgdn doth actions: dscroll
  238. 0 value srcOpen    \ store mkcfa or 0.
  239. : NoSrc false -> srcOpen ;
  240. 4 'cfas NoSrc null null null actions: dwind
  241. : loadr ( addr len --)
  242.     new: loadfile
  243.      name: topFile
  244.     open: topFile dup konstant fnfErr =
  245.     abort" file not in pathList"
  246.     abort" file error"
  247.     topFile size: topFile read: tempstr drop
  248.     builddwind
  249.     getName: topFile title: dwind
  250.     remove: loadfile   ;
  251. : see { \ xline wordPfa -- }
  252.     docs 0= abort" +docs not set"
  253.     @word count sfind
  254.     IF drop -> wordPfa
  255.         wordPfa nfa >line w@ extend -> xline
  256.         xline -1 <>
  257.         IF wordPfa findfmark
  258.             IF    srcOpen <>
  259.                 IF  new: tempStr
  260.                     mkCFA >name n>count loadr mkCFA -> srcOpen
  261.                      xline putLine: dpane
  262.                      lock: tempstr get: tempstr print: dwind unlock: tempstr show: dwind
  263.                      release: tempstr 
  264.                 ELSE xline moveto: dpane
  265.                 THEN
  266.             ELSE ." word not marked"
  267.             THEN
  268.         ELSE ." word not marked"
  269.         THEN
  270.     ELSE ." not found"
  271.     THEN  ;
  272. \ : qhit? ( n n - b) drop $ ff and ascii q = ;
  273. \ \ for testing textctl entries
  274. \ : kk BEGIN
  275. \         next: fevent
  276. \         IF actw fwind =
  277. \             IF  qhit?
  278. \                 IF exit THEN
  279. \             ELSE drop key: actw
  280. \             THEN
  281. \         THEN
  282. \     AGAIN ;
  283. ;module
  284.